home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tclX-6.4 / tk.tlib < prev    next >
Encoding:
Text File  |  1992-12-17  |  17.5 KB  |  589 lines
  1. #@package: button.tcl tk_butEnter tk_butLeave tk_butDown tk_butUp
  2.  
  3. # button.tcl --
  4. #
  5. # This file contains Tcl procedures used to manage Tk buttons.
  6. #
  7. # $Header: /user6/ouster/wish/scripts/RCS/button.tcl,v 1.7 92/07/28 15:41:13 ouster Exp $ SPRITE (Berkeley)
  8. #
  9. # Copyright 1992 Regents of the University of California
  10. # Permission to use, copy, modify, and distribute this
  11. # software and its documentation for any purpose and without
  12. # fee is hereby granted, provided that this copyright
  13. # notice appears in all copies.  The University of California
  14. # makes no representations about the suitability of this
  15. # software for any purpose.  It is provided "as is" without
  16. # express or implied warranty.
  17. #
  18.  
  19. # The procedure below is invoked when the mouse pointer enters a
  20. # button widget.  It records the button we're in and changes the
  21. # state of the button to active unless the button is disabled.
  22.  
  23. proc tk_butEnter w {
  24.     global tk_priv tk_strictMotif
  25.     if {[lindex [$w config -state] 4] != "disabled"} {
  26.     if {!$tk_strictMotif} {
  27.         $w config -state active
  28.     }
  29.     set tk_priv(window) $w
  30.     }
  31. }
  32.  
  33. # The procedure below is invoked when the mouse pointer leaves a
  34. # button widget.  It changes the state of the button back to
  35. # inactive.
  36.  
  37. proc tk_butLeave w {
  38.     global tk_priv tk_strictMotif
  39.     if {[lindex [$w config -state] 4] != "disabled"} {
  40.     if {!$tk_strictMotif} {
  41.         $w config -state normal
  42.     }
  43.     }
  44.     set tk_priv(window) ""
  45. }
  46.  
  47. # The procedure below is invoked when the mouse button is pressed in
  48. # a button/radiobutton/checkbutton widget.  It records information
  49. # (a) to indicate that the mouse is in the button, and
  50. # (b) to save the button's relief so it can be restored later.
  51.  
  52. proc tk_butDown w {
  53.     global tk_priv
  54.     set tk_priv(relief) [lindex [$w config -relief] 4]
  55.     if {[lindex [$w config -state] 4] != "disabled"} {
  56.     $w config -relief sunken
  57.     }
  58. }
  59.  
  60. # The procedure below is invoked when the mouse button is released
  61. # for a button/radiobutton/checkbutton widget.  It restores the
  62. # button's relief and invokes the command as long as the mouse
  63. # hasn't left the button.
  64.  
  65. proc tk_butUp w {
  66.     global tk_priv
  67.     $w config -relief $tk_priv(relief)
  68.     if {($w == $tk_priv(window))
  69.         && ([lindex [$w config -state] 4] != "disabled")} {
  70.     uplevel #0 [list $w invoke]
  71.     }
  72. }
  73. #@package: listbox.tcl tk_listboxSingleSelect
  74.  
  75. # listbox.tcl --
  76. #
  77. # This file contains Tcl procedures used to manage Tk listboxes.
  78. #
  79. # $Header: /user6/ouster/wish/scripts/RCS/listbox.tcl,v 1.2 92/06/03 15:21:28 ouster Exp $ SPRITE (Berkeley)
  80. #
  81. # Copyright 1992 Regents of the University of California
  82. # Permission to use, copy, modify, and distribute this
  83. # software and its documentation for any purpose and without
  84. # fee is hereby granted, provided that this copyright
  85. # notice appears in all copies.  The University of California
  86. # makes no representations about the suitability of this
  87. # software for any purpose.  It is provided "as is" without
  88. # express or implied warranty.
  89. #
  90.  
  91. # The procedure below may be invoked to change the behavior of
  92. # listboxes so that only a single item may be selected at once.
  93. # The arguments give one or more windows whose behavior should
  94. # be changed;  if one of the arguments is "Listbox" then the default
  95. # behavior is changed for all listboxes.
  96.  
  97. proc tk_listboxSingleSelect args {
  98.     foreach w $args {
  99.     bind $w <B1-Motion> {%W select from [%W nearest %y]} 
  100.     bind $w <Shift-1> {%W select from [%W nearest %y]}
  101.     bind $w <Shift-B1-Motion> {%W select from [%W nearest %y]}
  102.     }
  103. }
  104. #@package: tkerror.tcl tkerror
  105.  
  106. # This file contains a default version of the tkError procedure.  It
  107. # just prints out a stack trace.
  108.  
  109. proc tkerror err {
  110.     global errorInfo
  111.     puts stdout "$errorInfo"
  112. }
  113. #@package: text.tcl tk_textSelectTo tk_textBackspace tk_textIndexCloser tk_textResetAnchor
  114.  
  115. # text.tcl --
  116. #
  117. # This file contains Tcl procedures used to manage Tk entries.
  118. #
  119. # $Header: /user6/ouster/wish/scripts/RCS/text.tcl,v 1.2 92/07/16 16:26:33 ouster Exp $ SPRITE (Berkeley)
  120. #
  121. # Copyright 1992 Regents of the University of California
  122. # Permission to use, copy, modify, and distribute this
  123. # software and its documentation for any purpose and without
  124. # fee is hereby granted, provided that this copyright
  125. # notice appears in all copies.  The University of California
  126. # makes no representations about the suitability of this
  127. # software for any purpose.  It is provided "as is" without
  128. # express or implied warranty.
  129. #
  130.  
  131. # The procedure below is invoked when dragging one end of the selection.
  132. # The arguments are the text window name and the index of the character
  133. # that is to be the new end of the selection.
  134.  
  135. proc tk_textSelectTo {w index} {
  136.     global tk_priv
  137.  
  138.     case $tk_priv(selectMode) {
  139.     char {
  140.         if [$w compare $index < anchor] {
  141.         set first $index
  142.         set last anchor
  143.         } else {
  144.         set first anchor
  145.         set last [$w index $index+1c]
  146.         }
  147.     }
  148.     word {
  149.         if [$w compare $index < anchor] {
  150.         set first [$w index "$index wordstart"]
  151.         set last [$w index "anchor wordend"]
  152.         } else {
  153.         set first [$w index "anchor wordstart"]
  154.         set last [$w index "$index wordend"]
  155.         }
  156.     }
  157.     line {
  158.         if [$w compare $index < anchor] {
  159.         set first [$w index "$index linestart"]
  160.         set last [$w index "anchor lineend + 1c"]
  161.         } else {
  162.         set first [$w index "anchor linestart"]
  163.         set last [$w index "$index lineend + 1c"]
  164.         }
  165.     }
  166.     }
  167.     $w tag remove sel 0.0 $first
  168.     $w tag add sel $first $last
  169.     $w tag remove sel $last end
  170. }
  171.  
  172. # The procedure below is invoked to backspace over one character in
  173. # a text widget.  The name of the widget is passed as argument.
  174.  
  175. proc tk_textBackspace w {
  176.     $w delete insert-1c insert
  177. }
  178.  
  179. # The procedure below compares three indices, a, b, and c.  Index b must
  180. # be less than c.  The procedure returns 1 if a is closer to b than to c,
  181. # and 0 otherwise.  The "w" argument is the name of the text widget in
  182. # which to do the comparison.
  183.  
  184. proc tk_textIndexCloser {w a b c} {
  185.     set a [$w index $a]
  186.     set b [$w index $b]
  187.     set c [$w index $c]
  188.     if [$w compare $a <= $b] {
  189.     return 1
  190.     }
  191.     if [$w compare $a >= $c] {
  192.     return 0
  193.     }
  194.     scan $a "%d.%d" lineA chA
  195.     scan $b "%d.%d" lineB chB
  196.     scan $c "%d.%d" lineC chC
  197.     if {$chC == 0} {
  198.     incr lineC -1
  199.     set chC [string length [$w get $lineC.0 $lineC.end]]
  200.     }
  201.     if {$lineB != $lineC} {
  202.     return [expr {($lineA-$lineB) < ($lineC-$lineA)}]
  203.     }
  204.     return [expr {($chA-$chB) < ($chC-$chA)}]
  205. }
  206.  
  207. # The procedure below is called to reset the selection anchor to
  208. # whichever end is FARTHEST from the index argument.
  209.  
  210. proc tk_textResetAnchor {w index} {
  211.     global tk_priv
  212.     if {[$w tag ranges sel] == ""} {
  213.     set tk_priv(selectMode) char
  214.     $w mark set anchor $index
  215.     return
  216.     }
  217.     if [tk_textIndexCloser $w $index sel.first sel.last] {
  218.     if {$tk_priv(selectMode) == "char"} {
  219.         $w mark set anchor sel.last
  220.     } else {
  221.         $w mark set anchor sel.last-1c
  222.     }
  223.     } else {
  224.     $w mark set anchor sel.first
  225.     }
  226. }
  227. #@package: menu.tcl tk_menus tk_bindForTraversal tk_mbPost tk_mbUnpost tk_traverseToMenu tk_traverseWithinMenu tk_getMenuButtons tk_nextMenu tk_nextMenuEntry tk_invokeMenu tk_firstMenu
  228.  
  229. # menu.tcl --
  230. #
  231. # This file contains Tcl procedures used to manage Tk menus and
  232. # menubuttons.  Most of the code here is dedicated to support for
  233. # menu traversal via the keyboard.
  234. #
  235. # $Header: /user6/ouster/wish/scripts/RCS/menu.tcl,v 1.11 92/08/08 14:49:55 ouster Exp $ SPRITE (Berkeley)
  236. #
  237. # Copyright 1992 Regents of the University of California
  238. # Permission to use, copy, modify, and distribute this
  239. # software and its documentation for any purpose and without
  240. # fee is hereby granted, provided that this copyright
  241. # notice appears in all copies.  The University of California
  242. # makes no representations about the suitability of this
  243. # software for any purpose.  It is provided "as is" without
  244. # express or implied warranty.
  245. #
  246.  
  247. # The procedure below is publically available.  It is used to indicate
  248. # the menus associated with a particular top-level window, for purposes
  249. # of keyboard menu traversal.  Its first argument is the path name of
  250. # a top-level window, and any additional arguments are the path names of
  251. # the menu buttons associated with that top-level window, in the order
  252. # they should be traversed.  If no menu buttons are named, the procedure
  253. # returns the current list of menus for w.  If a single empty string is
  254. # supplied, then the menu list for w is cancelled.  Otherwise, tk_menus
  255. # sets the menu list for w to the menu buttons.
  256.  
  257. proc tk_menus {w args} {
  258.     global tk_priv
  259.  
  260.     if {$args == ""} {
  261.     if [catch {set result [set tk_priv(menusFor$w)]}] {
  262.         return ""
  263.     }
  264.     return $result
  265.     }
  266.  
  267.     if {$args == "{}"} {
  268.     catch {unset tk_priv(menusFor$w)}
  269.     return ""
  270.     }
  271.  
  272.     set tk_priv(menusFor$w) $args
  273. }
  274.  
  275. # The procedure below is publically available.  It takes any number of
  276. # arguments taht are names of widgets or classes.  It sets up bindings
  277. # for the widgets or classes so that keyboard menu traversal is possible
  278. # when the input focus is in those widgets or classes.
  279.  
  280. proc tk_bindForTraversal args {
  281.     foreach w $args {
  282.     bind $w <Alt-KeyPress> {tk_traverseToMenu %W %A}
  283.     bind $w <F10> {tk_firstMenu %W}
  284.     }
  285. }
  286.  
  287. # The procedure below does all of the work of posting a menu (including
  288. # unposting any other menu that might currently be posted).  The "w"
  289. # argument is the name of the menubutton for the menu to be posted.
  290. # Note:  if $w is disabled then the procedure does nothing.
  291.  
  292. proc tk_mbPost {w} {
  293.     global tk_priv tk_strictMotif
  294.     if {[lindex [$w config -state] 4] == "disabled"} {
  295.     return
  296.     }
  297.     set cur $tk_priv(posted)
  298.     if {$cur == $w} {
  299.     return
  300.     }
  301.     if {$cur != ""} tk_mbUnpost
  302.     set tk_priv(relief) [lindex [$w config -relief] 4]
  303.     $w config -relief raised
  304.     set tk_priv(cursor) [lindex [$w config -cursor] 4]
  305.     $w config -cursor arrow
  306.     $w post
  307.     grab -global $w
  308.     set tk_priv(posted) $w
  309.     if {$tk_priv(focus) == ""} {
  310.     set tk_priv(focus) [focus]
  311.     }
  312.     set menu [lindex [$w config -menu] 4]
  313.     set tk_priv(activeBg) [lindex [$menu config -activebackground] 4]
  314.     set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4]
  315.     if $tk_strictMotif {
  316.     $menu config -activebackground [lindex [$menu config -background] 4]
  317.     $menu config -activeforeground [lindex [$menu config -foreground] 4]
  318.     }
  319.     focus $menu
  320. }
  321.  
  322. # The procedure below does all the work of unposting the menubutton that's
  323. # currently posted.  It takes no arguments.
  324.  
  325. proc tk_mbUnpost {} {
  326.     global tk_priv
  327.     if {$tk_priv(posted) != ""} {
  328.     $tk_priv(posted) config -relief $tk_priv(relief)
  329.     $tk_priv(posted) config -cursor $tk_priv(cursor)
  330.     $tk_priv(posted) config -activebackground $tk_priv(activeBg)
  331.     $tk_priv(posted) config -activeforeground $tk_priv(activeFg)
  332.     $tk_priv(posted) unpost
  333.     grab none
  334.     focus $tk_priv(focus)
  335.     set tk_priv(focus) ""
  336.     set menu [lindex [$tk_priv(posted) config -menu] 4]
  337.     $menu config -activebackground $tk_priv(activeBg)
  338.     $menu config -activeforeground $tk_priv(activeFg)
  339.     set tk_priv(posted) {}
  340.     }
  341. }
  342.  
  343. # The procedure below is invoked to implement keyboard traversal to
  344. # a menu button.  It takes two arguments:  the name of a window where
  345. # a keystroke originated, and the ascii character that was typed.
  346. # This procedure finds a menu bar by looking upward for a top-level
  347. # window, then looking for a window underneath that named "menu".
  348. # Then it searches through all the subwindows of "menu" for a menubutton
  349. # with an underlined character matching char.  If one is found, it
  350. # posts that menu.
  351.  
  352. proc tk_traverseToMenu {w char} {
  353.     global tk_priv
  354.     if {$char == ""} {
  355.     return
  356.     }
  357.     set char [string tolower $char]
  358.  
  359.     foreach mb [tk_getMenuButtons $w] {
  360.     if {[winfo class $mb] == "Menubutton"} {
  361.         set char2 [string index [lindex [$mb config -text] 4] \
  362.             [lindex [$mb config -underline] 4]]
  363.         if {[string compare $char [string tolower $char2]] == 0} {
  364.         tk_mbPost $mb
  365.         [lindex [$mb config -menu] 4] activate 0
  366.         return
  367.         }
  368.     }
  369.     }
  370. }
  371.  
  372. # The procedure below is used to implement keyboard traversal within
  373. # the posted menu.  It takes two arguments:  the name of the menu to
  374. # be traversed within, and an ASCII character.  It searches for an
  375. # entry in the menu that has that character underlined.  If such an
  376. # entry is found, it is invoked and the menu is unposted.
  377.  
  378. proc tk_traverseWithinMenu {w char} {
  379.     if {$char == ""} {
  380.     return
  381.     }
  382.     set char [string tolower $char]
  383.     set last [$w index last]
  384.     for {set i 0} {$i <= $last} {incr i} {
  385.     if [catch {set char2 [string index \
  386.         [lindex [$w entryconfig $i -label] 4] \
  387.         [lindex [$w entryconfig $i -underline] 4]]}] {
  388.         continue
  389.     }
  390.     if {[string compare $char [string tolower $char2]] == 0} {
  391.         tk_mbUnpost
  392.         $w invoke $i
  393.         return
  394.     }
  395.     }
  396. }
  397.  
  398. # The procedure below takes a single argument, which is the name of
  399. # a window.  It returns a list containing path names for all of the
  400. # menu buttons associated with that window's top-level window, or an
  401. # empty list if there are none.
  402.  
  403. proc tk_getMenuButtons w {
  404.     global tk_priv
  405.     set top [winfo toplevel $w]
  406.     if [catch {set buttons [set tk_priv(menusFor$top)]}] {
  407.     return ""
  408.     }
  409.     return $buttons
  410. }
  411.  
  412. # The procedure below is used to traverse to the next or previous
  413. # menu in a menu bar.  It takes one argument, which is a count of
  414. # how many menu buttons forward or backward (if negative) to move.
  415. # If there is no posted menu then this procedure has no effect.
  416.  
  417. proc tk_nextMenu count {
  418.     global tk_priv
  419.     if {$tk_priv(posted) == ""} {
  420.     return
  421.     }
  422.     set buttons [tk_getMenuButtons $tk_priv(posted)]
  423.     set length [llength $buttons]
  424.     for {set i 0} 1 {incr i} {
  425.     if {$i >= $length} {
  426.         return
  427.     }
  428.     if {[lindex $buttons $i] == $tk_priv(posted)} {
  429.         break
  430.     }
  431.     }
  432.     incr i $count
  433.     while 1 {
  434.     while {$i < 0} {
  435.         incr i $length
  436.     }
  437.     while {$i >= $length} {
  438.         incr i -$length
  439.     }
  440.     set mb [lindex $buttons $i]
  441.     if {[lindex [$mb configure -state] 4] != "disabled"} {
  442.         break
  443.     }
  444.     incr i $count
  445.     }
  446.     tk_mbUnpost
  447.     tk_mbPost $mb
  448.     [lindex [$mb config -menu] 4] activate 0
  449. }
  450.  
  451. # The procedure below is used to traverse to the next or previous entry
  452. # in the posted menu.  It takes one argument, which is 1 to go to the
  453. # next entry or -1 to go to the previous entry.  Disabled entries are
  454. # skipped in this process.
  455.  
  456. proc tk_nextMenuEntry count {
  457.     global tk_priv
  458.     if {$tk_priv(posted) == ""} {
  459.     return
  460.     }
  461.     set menu [lindex [$tk_priv(posted) config -menu] 4]
  462.     set length [expr [$menu index last]+1]
  463.     set i [$menu index active]
  464.     if {$i == "none"} {
  465.     set i 0
  466.     } else {
  467.     incr i $count
  468.     }
  469.     while 1 {
  470.     while {$i < 0} {
  471.         incr i $length
  472.     }
  473.     while {$i >= $length} {
  474.         incr i -$length
  475.     }
  476.     if {[catch {$menu entryconfigure $i -state} state] == 0} {
  477.         if {[lindex $state 4] != "disabled"} {
  478.         break
  479.         }
  480.     }
  481.     incr i $count
  482.     }
  483.     $menu activate $i
  484. }
  485.  
  486. # The procedure below invokes the active entry in the posted menu,
  487. # if there is one.  Otherwise it does nothing.
  488.  
  489. proc tk_invokeMenu {menu} {
  490.     set i [$menu index active]
  491.     if {$i != "none"} {
  492.     tk_mbUnpost
  493.     update idletasks
  494.     $menu invoke $i
  495.     }
  496. }
  497.  
  498. # The procedure below is invoked to keyboard-traverse to the first
  499. # menu for a given source window.  The source window is passed as
  500. # parameter.
  501.  
  502. proc tk_firstMenu w {
  503.     set mb [lindex [tk_getMenuButtons $w] 0]
  504.     if {$mb != ""} {
  505.     tk_mbPost $mb
  506.     [lindex [$mb config -menu] 4] activate 0
  507.     }
  508. }
  509.  
  510. # The procedure below is invoked when a button-1-down event is
  511. # received by a menu button.  If the mouse is in the menu button
  512. # then it posts the button's menu.  If the mouse isn't in the
  513. # button's menu, then it deactivates any active entry in the menu.
  514. # Remember, event-sharing can cause this procedure to be invoked
  515. # for two different menu buttons on the same event.
  516.  
  517. proc tk_mbButtonDown w {
  518.     global tk_priv
  519.     if {[lindex [$w config -state] 4] == "disabled"} {
  520.     return
  521.     } 
  522.     if {$tk_priv(inMenuButton) == $w} {
  523.     tk_mbPost $w
  524.     }
  525.     set menu [lindex [$tk_priv(posted) config -menu] 4]
  526.     if {$tk_priv(window) != $menu} {
  527.     $menu activate none
  528.     }
  529. }
  530. #@package: entry.tcl tk_entryBackspace tk_entryBackword tk_entrySeeCaret
  531.  
  532. # entry.tcl --
  533. #
  534. # This file contains Tcl procedures used to manage Tk entries.
  535. #
  536. # $Header: /user6/ouster/wish/scripts/RCS/entry.tcl,v 1.2 92/05/23 16:40:57 ouster Exp $ SPRITE (Berkeley)
  537. #
  538. # Copyright 1992 Regents of the University of California
  539. # Permission to use, copy, modify, and distribute this
  540. # software and its documentation for any purpose and without
  541. # fee is hereby granted, provided that this copyright
  542. # notice appears in all copies.  The University of California
  543. # makes no representations about the suitability of this
  544. # software for any purpose.  It is provided "as is" without
  545. # express or implied warranty.
  546. #
  547.  
  548. # The procedure below is invoked to backspace over one character
  549. # in an entry widget.  The name of the widget is passed as argument.
  550.  
  551. proc tk_entryBackspace w {
  552.     set x [expr {[$w index cursor] - 1}]
  553.     if {$x != -1} {$w delete $x}
  554. }
  555.  
  556. # The procedure below is invoked to backspace over one word in an
  557. # entry widget.  The name of the widget is passed as argument.
  558.  
  559. proc tk_entryBackword w {
  560.     set string [$w get]
  561.     set curs [expr [$w index cursor]-1]
  562.     if {$curs < 0} return
  563.     for {set x $curs} {$x > 0} {incr x -1} {
  564.     if {([string first [string index $string $x] " \t"] < 0)
  565.         && ([string first [string index $string [expr $x-1]] " \t"]
  566.         >= 0)} {
  567.         break
  568.     }
  569.     }
  570.     $w delete $x $curs
  571. }
  572.  
  573. # The procedure below is invoked after insertions.  If the caret is not
  574. # visible in the window then the procedure adjusts the entry's view to
  575. # bring the caret back into the window again.
  576.  
  577. proc tk_entrySeeCaret w {
  578.     set c [$w index cursor]
  579.     set left [$w index @0]
  580.     if {$left > $c} {
  581.     $w view $c
  582.     return
  583.     }
  584.     while {[$w index @[expr [winfo width $w]-5]] < $c} {
  585.     set left [expr $left+1]
  586.     $w view $left
  587.     }
  588. }
  589.